perm filename LISS.F4[JC,MUS]1 blob sn#007319 filedate 1972-07-16 generic text, type T, neo UTF8
00100		SUBROUTINE SPACE4(AMP,RAMP,DOP,CHNA,CHNB,CHNC,CHND,ARRAY)
00200		DIMENSION AMP(512),RAMP(512),DOP(512),
00300		1 CHNA(512),CHNB(512),CHNC(512),CHND(512)
00400		DIMENSION F(7),G(3)
00500	     	DIMENSION ARRAY(2,600),B(4),C(3),D(4),E(7)
00600		DIMENSION ST(50),SU(350)
00700		DATA (B(I),I=1,3)/'A TO B IN FT.'/
00800		DATA (C(I),I=1,3)/'LISS=1,LINE=2'/
00900		DATA (D(I),I=1,3)/'0=FIN,1=REDEF'/
01000		DATA (E(I),I=1,6)/'SEE AMP=1,DOP=2,STER1=3 OR 0'/
01100		DATA (F(I),I=1,6)/'X,Y,RAD OR X1,Y1,X2,Y2,X3,Y3'/
01200		DATA (G(I),I=1,2)/'CYCL TM='/
01300		CALL TYPLOC(-300,-512)
01400	101	CONTINUE
01450	C	CALL CLEAR
01500		CALL DPYSET(1,ST,50)
01600		CALL DPYBRT(1)
01700		CALL AIVECT(0,0)
01800		CALL HYDPOG(1)
01900		IF(KT1.EQ.1)KT1=513
02000		IY=100
02100		DO 11 I=1,2
02200		CALL ALINE(-100,IY,100,IY)
02300	11	IY=-IY
02400		IX=100
02500		DO 12 I=1,2
02600		CALL ALINE(IX,-100,IX,100)
02700	12	IX=-IX
02800		CALL ALINE(0,0,0,100)
02900		CALL DPYOUT(1)
03000	CC  SPACE DEFINITION FINISHED
03100		CALL MESS(B)
03200		CALL RDNUM(DIS)
03300		DELTA=DIS/100.0
03400		CALL MESS(C)
03500		CALL RDNUM(XNUM)
03600		IF(XNUM.EQ.0.0)GO TO 20
03700		L=XNUM
03800		CALL DPYSET(2,SU,350)
03900		CALL DPYBRT(6)
04000		CALL AIVECT(0,0)
04100		CALL MESS(F)
04200		GO TO (1,2,2),L
04300	1	CALL RDNUM(XCO)
04400		CALL RDNUM(YCO)
04500		CALL RDNUM(RADIUS)
04600		RADNS=(2.0*3.1415927)/512.0
04700		CRADNS=RADNS
04800		IL=1
04900	36	CONTINUE
05000		SINR=SIN(CRADNS)
05100		COSR=COS(CRADNS)
05200		CRADNS=CRADNS+RADNS
05300		ARRAY(1,IL)=SINR*RADIUS+XCO
05400		ARRAY(2,IL)=COSR*RADIUS+YCO
05500		GO TO 520
05600	2	CALL RDNUM(XCO1)
05700		CALL RDNUM(YCO1)
05800		CALL RDNUM(FREQX)
05900		CALL RDNUM(PHASX)
06000	      	CALL RDNUM(FREQY)
06100		CALL RDNUM(PHASY)
06200		CALL RDNUM(FREQ2X)
06210		CALL RDNUM(PHAS2X)
06220		CALL RDNUM(FREQ2Y)
06230		CALL RDNUM(PHAS2Y)
06300		CALL RDNUM(DIA)
06310		CALL RDNUM(DIA2)
06400		IF(L.EQ.3)GOTO 3
06500		XINC=(FREQX*360.)/512.
06510		XINC2=(FREQ2X*360.)/512.
06600		XK=-XINC+PHASX
06610		XK2=-XINC2+PHAS2X
06700		YINC=(FREQY*360.)/512.
06710		YINC2=(FREQ2Y*360.)/512.
06800		YK=-YINC+PHASY
06810		YK2=-YINC2+PHAS2Y
06900		IL=1
07000	37	CONTINUE
07100		XX=XK+XINC
07110		XX2=XK2+XINC2
07200		IF(XX.GE.360.)XX=XX-360.
07210		IF(XX2.GE.360.)XX2=XX2-360.
07300		XK=XX
07310		XK2=XX2
07400		YY=YK+YINC
07410		YY2=YK2+YINC2
07500		IF(YY.GE.360.)YY=YY-360.
07510		IF(YY2.GE.360.)YY2=YY2-360.
07600		YK=YY
07610		YK2=YY2
07700		ARRAY(1,IL)=XCO1+SIND(XX)*DIA+(SIND(XX2)*DIA2)
07800		ARRAY(2,IL)=YCO1+SIND(YY)*DIA+(SIND(YY2)*DIA2)
07900		GO TO 520
08000	3	CALL RDNUM(XCO3)
08100		CALL RDNUM(YCO3)
08200		XDIF1=XCO2-XCO1
08300		XDIF2=XCO3-XCO2
08400		YDIF1=YCO2-YCO1
08500		YDIF2=YCO3-YCO2
08600		XCO4=XCO2+XDIF2-XDIF1
08700		YCO4=YCO2+YDIF2-YDIF1	
08800		XCOI1=XDIF1/128.
08900		XCOI2=XDIF2/128.
09000		YCOI1=YDIF1/128.
09100		YCOI2=YDIF2/128.
09200	C	XCO1=XCO1-XCOI1
09300	C	YCO1=YCO1-YCOI1
09400		IL=1
09500	32	IF(IL.GT.128)GO TO 33
09600		ARRAY(1,IL)=XCO1+XCOI1
09700		ARRAY(2,IL)=YCO1+YCOI1
09800		XCO1=ARRAY(1,IL)
09900		YCO1=ARRAY(2,IL)
10000		GO TO 520
10100	33	IF(IL.GT.256.)GO TO 34
10200		ARRAY(1,IL)=XCO2+XCOI2
10300		ARRAY(2,IL)=YCO2+YCOI2
10400		XCO2=ARRAY(1,IL)
10500		YCO2=ARRAY(2,IL)
10600		GO TO 520
10700	34	IF(IL.GT.384)GO TO 35
10800		ARRAY(1,IL)=XCO3-XCOI1
10900		ARRAY(2,IL)=YCO3-YCOI1
11000		XCO3=ARRAY(1,IL)
11100		YCO3=ARRAY(2,IL)
11200		GO TO 520
11300	35	ARRAY(1,IL)=XCO4-XCOI2
11400	        ARRAY(2,IL)=YCO4-YCOI2
11500		XCO4=ARRAY(1,IL)
11600		YCO4=ARRAY(2,IL)
11700	520	NEWX=ARRAY(1,IL)
11800		NEWY=ARRAY(2,IL)
11900		IF(IL.GT.1)GO TO 503
12000		CALL AIVECT(NEWX,NEWY)
12100		GO TO 504
12200	503	CALL SVECT(NEWX-IOLDX,NEWY-IOLDY)
12300	504	IOLDX=NEWX
12400		IOLDY=NEWY
12500		CALL DPYOUT(2)
12600		IL=IL+1
12700		IF(IL.GT.512)GO TO 500
12800		GO TO (36,37,32),L
12900	500	CONTINUE
13000		M=512
13100		CALL MESS(G)
13200		CALL RDNUM(SPD1)
13300		SPD1=60.0/((1.0/SPD1)*512.0)
13400		GO TO 501
13500	20	SPD1=SPD
13600	C	CALL POS(ARRAY,600,M,SPD1)
13700	501	X=M-1
13800		AI=X/512.0
13900		BI=2.0
14000		S=60.0/SPD1
14100		R=SQRT(ARRAY(1,1)**2+ARRAY(2,1)**2)
14200		DO 100 J=1,512
14300		I=BI
14400		X=ARRAY(1,I)
14500		Y=ARRAY(2,I)
14600		BI=BI+AI
14700		R1=SQRT(X**2+Y**2)
14800		AMP(J)=DIS/(R1*DELTA)
14900		RAMP(J)=ALOG(DIS)/ALOG(R1*DELTA)
14950		IF(RAMP(J).GT.1.)RAMP(J)=1.
15000		CONTINUE
15100		VR=S*DELTA*(R1-R)
15200		XJ=J
15300		IF((R1.EQ.R).AND.(XJ.GT.1.0))GO TO 31
15400		DOP(J)=1180.0/(1180.0+VR)
15500		GO TO 21
15600	31	DOP(J)=DOP(J-1)
15700	21	R=R1
15800		CONTINUE
15900		AX=ABS(X)
16000		AY=ABS(Y)
16100		PI=3.1416
16200		ANGLE=AMOD(ATAN2(Y,X)+6.2832,6.2832)	
16300		PI2=PI/2.0
16400		IF((AX.LE.AY).AND.(Y.GT.0.0))GO TO 2000
16500		IF((AX.GT.AY).AND.(X.GT.0.0))GO TO 2001
16600		IF((AX.LE.AY).AND.(Y.LT.0.0))GO TO 2002
16700		CHN=ANGLE-(3.*PI)/4.	
16800		CHNB(J)=1.-CHN/PI2	
16900		CHNC(J)=CHN/PI2	
17000		CHNA(J)=0.0
17100		CHND(J)=0.0
17200		GO TO 100	
17300	2000	CHN=ANGLE-PI/4.
17400		CHNA(J)=1.-CHN/PI2	
17500		CHNB(J)=CHN/PI2	
17600		CHNC(J)=0.0
17700		CHND(J)=0.0
17800		GO TO 100	
17900	2001	CHN=ANGLE-(7.*PI)/4.	
18000		IF(ANGLE.LT.PI/4.)CHN=ANGLE+PI/4.
18100		CHND(J)=1.-CHN/PI2	
18200		CHNA(J)=CHN/PI2	
18300		CHNB(J)=0.0
18400		CHNC(J)=0.0
18500		GO TO 100	
18600	2002	CHN=ANGLE-(5.*PI)/4.	
18700		CHNC(J)=1.-CHN/PI2	
18800		CHND(J)=CHN/PI2	
18900		CHNA(J)=0.0
19000		CHNB(J)=0.0
19100	100	CONTINUE
19200		DO 402 JK=1,512
19300		CHNA(JK)=SQRT(CHNA(JK))
19400		CHNB(JK)=SQRT(CHNB(JK))
19500		CHNC(JK)=SQRT(CHNC(JK))
19600		CHND(JK)=SQRT(CHND(JK))
19700	402	CONTINUE
19800		CALL INTERP(AMP)
19900		CALL INTERP(RAMP)
20000		CALL INTERP(DOP)
20100	C	CALL INTERP(CHNA)
20200	C	CALL INTERP(CHNB)
20300	C	CALL INTERP(CHNC)
20400	C	CALL INTERP(CHND)
20500	801	CONTINUE
20600		GO TO 937
20700	99	CONTINUE
20800	937	CALL MESS(E)
20900		CALL RDNUM(X)
21000		L=X
21100		IF(L.EQ.0)GO TO 200
21200		IF(L.GT.3)GO TO 937
21300		CALL HYDPOG(1)
21400		CALL HYDPOG(2)
21500	C	CALL CLEAR
21600		CALL DPYSET(1,ST,50)
21700		CALL DPYBRT(1)
21800		CALL AIVECT(0,0)
21900		IF(L.EQ.3)GO TO 203
22000		CALL ALINE(-264,0,256,0)
22100		CALL ALINE(-256,-256,-256,256)
22200		CALL DPYOUT(1)
22300		CALL DPYSET(2,SU,350)
22400		CALL DPYBRT(6)
22500		CALL AIVECT(0,0)
22600		GO TO(201,202),L
22700	201	IY=AMP(1)*256.
22800		CALL AIVECT(-256,IY)
22900		DO 301 I=2,512
23000		IY2=AMP(I)*256.0
23100		CALL SVECT(1,IY2-IY)
23200		IY=IY2
23300	301	CALL DPYOUT(2)
23400		GO TO 99
23500	202	IY=DOP(1)*256.-256.
23600		CALL AIVECT(-256,IY)
23700		DO 302 I=2,512
23800		IY2=DOP(I)*256.0-256.
23900		CALL SVECT(1,IY2-IY)
24000		IY=IY2
24100	302	CALL DPYOUT(2)
24200		GO TO 99
24300	203	CONTINUE
24350	C	CALL CLEAR
24400		DO 300 J=-375,375,250
24500		CALL AIVECT(0,J)
24600		CALL RVECT(256,0)
24700		CALL RIVECT(-256,-125)
24800		CALL RVECT(0,250)
24900	300	CALL DPYOUT(1)
25000		CALL DPYSET(2,SU,350)
25100		CALL DPYBRT(6)
25200		CALL AIVECT(0,0)
25300		IY=375
25400		CALL DRAW(CHNA,IY)
25500		IY=125
25600		CALL DRAW(CHNB,IY)
25700		IY=-125
25800		CALL DRAW(CHNC,IY)
25900		IY=-375
26000		CALL DRAW(CHND,IY)
26100		GO TO 99
26200	200	CALL MESS(D)
26300		CALL RDNUM(X)
26400		IF(X.EQ.0.0)GO TO 307
26500		CALL HYDPOG(2)
26600		GO TO 101
26700	307	CONTINUE
26750	C	CALL CLEAR
26800		CALL DPYCLR
26900		RETURN
27000		END
27100	CC******WAVE DRAWER**********************************************
27200		SUBROUTINE DRAW(FUNC,ICT)
27300		DIMENSION FUNC(512)
27400		CALL AIVECT(0,ICT)
27500		DO 100 I=1,512,4
27600		IY2=FUNC(I)*125.
27700		IF(I.GT.1)GO TO 10
27800		CALL RIVECT(0,IY2)
27900		GO TO 101
28000	10	CALL SVECT(2,IY2-IY)
28100	101	IY=IY2
28200	100	CALL DPYOUT(2)
28300		RETURN
28400		END
28500	CC******WAVE SMOOTHER********************************************
28600		SUBROUTINE INTERP(CFUNC)
28700		DIMENSION CFUNC(512)
28800		JT=0
28900		DO 601 KT=2,512
29000		IF(CFUNC(KT-1).NE.CFUNC(KT))GO TO 600
29100		IF(JT.EQ.0)JT=KT-1
29200		GO TO 601
29300	600	IF(JT.EQ.0)GO TO 601
29400		DIFF=CFUNC(KT)-CFUNC(JT)
29500		DIV=KT-JT
29600		ANS=DIFF/DIV
29700		DO 602 LM=JT+1,KT-1
29800	602	CFUNC(LM)=CFUNC(LM-1)+ANS
29900		JT=0
30000	601	CONTINUE
30100		RETURN
30200		END